(COMMENT This file contains two versions of the index
	 program The first runs faster than the second by
	 attaching to each entry in the list to be sorted
	 a key derived from the appropriate PNAME The
	 second would probably be as fast if suitable
	 privitives were hand coded It is a simpler
	 structure and is ammenable to some improvement
	 in format in the case where various objects of
	 different types have the same name)

(DECLARE (SPECIAL FILENAME FUNLIST PAGELINE STIME)
	 (SPECIAL BASE *NOPOINT))

(DE ADDTOFUNLIST (NAME TYPE)
 (SETQ FUNLIST (MERGE (MKENTRY NAME
			       TYPE
			       (CONS FILENAME PAGELINE))
		      FUNLIST)))

(DE ALPHLESS (AT1 AT2)
	     (PNAMELESS	(GET AT1 (QUOTE PNAME))
			(GET AT2 (QUOTE PNAME))))

(DE ATTACHKEY (LIST) (CONS (MKKEY LIST) LIST))

(DE CURCOL NIL (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))

(DE DEDFDMAUX (ARG2 TYPE) 
    (ADDTOFUNLIST (COND ((ATOM ARG2) ARG2) (T (CAR ARG2)))
		  TYPE))


(DEFPROP INDEX
 (LAMBDA (FILES)
  (PROG (EXPR FILENAME FUNLIST INDEV OUTDEV OUTFILE
	 PAGELINE STIME)
	(SETQ INDEV (QUOTE DSK:))
	(SETQ OUTDEV (QUOTE DSK:))
   OLOOP(COND ((NULL FILES)
	       (PRINTINDEX OUTDEV OUTFILE FUNLIST)
	       (RETURN NIL)))
	(COND ((ISINPUT (CAR FILES)) (GO IN))
	      ((ISOUTPUT (CAR FILES)) (GO OUT)))
	(INC (EVAL (LIST (QUOTE INPUT)
			 INDEV
			 (CAR FILES)))
	     NIL)
	(SETQ FILENAME (CAR FILES))
	(SETQ STIME (TIME))
   ILOOP(SETQ EXPR (ERRSET (NEWREAD)))
	(COND ((EQ EXPR (QUOTE $EOF$)) (GO ELOOP)))
	(PROCESSEXPR (CAR EXPR))
	(GO ILOOP)
   ELOOP(INC NIL T)
	(SETQ FILES (CDR FILES))
	(GO OLOOP)
   IN	(SETQ INDEV (CAR FILES))
	(GO ELOOP)
   OUT	(PRINTINDEX OUTDEV OUTFILE FUNLIST)
	(SETQ OUTFILE (COND ((NULL (CDAR FILES))
			     (CAAR FILES))
			    (T (CADAR FILES))))
	(COND ((NOT (NULL (CDAR FILES)))
	       (SETQ OUTDEV (CAAR FILES))))
	(GO ELOOP)))
 FEXPR)

(DE INDEXDE (EXPR)
	    (DEDFDMAUX (CADR EXPR) (QUOTE EXPR)))

(DE INDEXDECLARE (EXPR)
    (MAPC (FUNCTION PROCESSEXPR) (CDR EXPR)))

(DE INDEXDEFPROP (EXPR)
    (COND ((GET (CADDDR EXPR) (QUOTE INDTYPE))
	   (ADDTOFUNLIST (CADR EXPR) (CADDDR EXPR)))))

(DE INDEXDEFUN (EXPR)
    (PROG (LEN)
	  (SETQ LEN (LENGTH EXPR))
	  (COND	((EQUAL LEN 4)
		 (ADDTOFUNLIST (CADR EXPR) (QUOTE EXPR))
		 (RETURN NIL)))
	  (ADDTOFUNLIST (CADR EXPR) (CADDR EXPR))))

(DE INDEXDF (EXPR)
	    (DEDFDMAUX (CADR EXPR) (QUOTE FEXPR)))

(DE INDEXDFUNC (EXPR)
	       (ADDTOFUNLIST (CAADR EXPR) (QUOTE EXPR)))


(DE INDEXDM (EXPR)
	    (DEDFDMAUX (CADR EXPR) (QUOTE MACRO)))

(DE INDEXLAP (EXPR)
    (COND ((GET (CADDR EXPR) (QUOTE INDTYPE))
	   (ADDTOFUNLIST (CADR EXPR) (CADDR EXPR)))))

(DE INDEXSETQ (EXPR)
	      (ADDTOFUNLIST (CADR EXPR) (QUOTE VALUE)))

(DE INDEXSPECIAL (EXPR)
    (PROG (VARS)
	  (SETQ VARS (CDR EXPR))
     LOOP (COND ((NULL VARS) (RETURN NIL)))
	  (ADDTOFUNLIST (CAR VARS) (QUOTE SPECIAL))
	  (SETQ VARS (CDR VARS))
	  (GO LOOP)))

(DE ISAREA (EXPR)
	   (AND	(NOT (ATOM EXPR))
		(NOT (ATOM (CDR EXPR)))
		(NOT (ISDEV (CAR EXPR)))))

(DE ISDEV (EXPR)
    (AND (ATOM EXPR)
	 (EQ (CAR (LAST (EXPLODE EXPR))) (QUOTE :))))

(DE ISFILE (EXPR)
    (OR	(AND (ATOM EXPR) (NOT (ISDEV EXPR)))
	(AND (NOT (ATOM EXPR)) (ATOM (CDR EXPR)))))

(DE ISINPUT (EXPR) (OR (ISDEV EXPR) (ISAREA EXPR)))

(DE ISLESS (L1 L2)
 (COND (USEKEY (KEYLESS L1 L2)) (T (ALPHALESS L1 L2))))

(DE ISOUTPUT (EXPR)
    (AND (NOT (ATOM EXPR))
	 (OR (AND (NULL (CDR EXPR)) (ISFILE (CAR EXPR)))
	     (AND (NOT (ATOM (CDR EXPR)))
		  (ISDEV (CAR EXPR))))))

(DE KEYLESS (L1 L2)
	    (COND ((LESSP (CAR L1) (CAR L2)) T)
		  ((LESSP (CAR L2) (CAR L1)) NIL)
		  (T (KEYLESSL (CDR L1) (CDR L2)))))

(DE KEYLESSL (L1 L2)
	     (COND ((NULL L1) T)
		   ((NULL L2) NIL)
		   (T (KEYLESS L1 L2))))

(DE LINEF (N)
	  (PROG NIL
	   LOOP	(COND ((ZEROP N) (RETURN NIL)))
		(TERPRI)
		(SETQ N (SUB1 N))
		(GO LOOP)))


(DE MERGE (ELEM LIST)
 (PROG (TEM)
       (SETQ TEM LIST)
  LOOP (COND ((NULL TEM) (RETURN (LIST ELEM))))
       (COND ((ISLESS (CAR ELEM) (CAAR TEM))
	      (RPLACA (RPLACD TEM
			      (CONS (CAR TEM) (CDR TEM)))
		      ELEM)
	      (RETURN LIST)))
       (COND ((NULL (CDR TEM)) (NCONC TEM (LIST ELEM))
			       (RETURN LIST)))
       (SETQ TEM (CDR TEM))
       (GO LOOP)))

(DE MKENTRY (NAME TYPE LOC)
    (COND (USEKEY (ATTACHKEY (LIST NAME TYPE LOC)))
	  (T (LIST NAME TYPE LOC))))

(DE MKKEY (ITEM)
 (PROG (PNAME KEY)
       (SETQ PNAME (GET (CAR ITEM) (QUOTE PNAME)))
  LOOP (COND ((NULL PNAME) (RETURN (REVERSE KEY))))
       (SETQ KEY (CONS (EXAMINE	(MAKNUM	(CAR PNAME)
					(QUOTE FIXNUM)))
		       KEY))
       (SETQ PNAME (CDR PNAME))
       (GO LOOP)))

(DE NEWREAD NIL
 (PROG NIL
  LOOP (COND ((MEMQ (NEXTTYI) (QUOTE (11 12 14 15 40)))
	      (TYI)
	      (GO LOOP)))
       (SETQ PAGELINE (PGLINE))
       (RETURN (READ))))

(DE NONKEYPART (ENTRY)
	       (COND (USEKEY (CDR ENTRY)) (T ENTRY)))

(DEFSYM (QUOTE TYI) 1027)

(DEFSYM (QUOTE OLDCH) 1112)

(LAP NEXTTYI SUBR)
	(PUSHJ P TYI)
	(MOVEM 1 OLDCH)
	(JRST 0 FIX1A)
	NIL

(DE PNAMELESS (L1 L2)
    ((LAMBDA (W1 W2)
	     (COND ((LESSP W1 W2) T)
		   ((LESSP W2 W1) NIL)
		   (T (PNAMELESSL (CDR L1) (CDR L2)))))
     (EXAMINE (MAKNUM (CAR L1) (QUOTE FIXNUM)))
     (EXAMINE (MAKNUM (CAR L2) (QUOTE FIXNUM)))))

(DE PNAMELESSL (L1 L2)
	       (COND ((NULL L1) T)
		     ((NULL L2) NIL)
		     (T (PNAMELESS L1 L2))))

(DE PRINL (L) (MAPC (FUNCTION PRINS) L))


(DE PRINS (EXP) (PROG2 (PRIN1 EXP) (PRINC (ASCII 40))))

(DE PRINTHEADING NIL
		 (PROG NIL
		       (PRIN1 (QUOTE NAME))
		       (TABTO 30)
		       (PRIN1 (QUOTE TYPE))
		       (TABTO 50)
		       (PRIN1 (QUOTE FILE))
		       (TABTO 70)
		       (PRIN1 (QUOTE PAGE))
		       (TABTO 100)
		       (PRIN1 (QUOTE LINE))
		       (LINEF 3)))

(DE PRINTENTRY (DATUM)
    (PROG NIL
	  (PRIN1 (CAR DATUM))
	  (TABTO 30)
	  (PRIN1 (CADR DATUM))
	  (TABTO 50)
	  (COND	((ATOM (CAR (CADDR DATUM)))
		 (PRIN1 (CAR (CADDR DATUM))))
		(T (PRIN1 (CAR (CAR (CADDR DATUM))))
		   (PRINC (ASCII 56))
		   (PRIN1 (CDR (CAR (CADDR DATUM))))))
	  (TABTO 70)
	  (PRIN1 (CADR (CADDR DATUM)))
	  (TABTO 100)
	  (PRIN1 (CDDR (CADDR DATUM)))
	  (LINEF 1)))

(DE PRINTINDEX (DEV FILE DATA)
 (PROG (*NOPOINT BASE COUNT)
       (SETQ COUNT 0)
       (COND ((NULL DATA) (RETURN NIL)))
       (COND ((NOT (NULL FILE))
	      (OUTC (EVAL (LIST (QUOTE OUTPUT) DEV FILE))
		    NIL)))
       (SETQ BASE (PLUS 5 5))
       (SETQ *NOPOINT T)
       (PRINTHEADING)
  LOOP (COND ((NULL DATA) (GO EXIT)))
       (PRINTENTRY (NONKEYPART (CAR DATA)))
       (SETQ DATA (CDR DATA))
       (SETQ COUNT (ADD1 COUNT))
       (GO LOOP)
  EXIT (OUTC NIL T)
       (PRINT COUNT)
       (PRINL (QUOTE (ENTRIES IN INDEX)))
       (PRINS (ADD1 (QUOTIENT (*DIF (TIME) STIME) 1750)))
       (PRINS (QUOTE SECONDS))))

(DE PRINTN (CHAR NUM)
	   (PROG (NO)
		 (SETQ NO 1)
	    LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
		 (PRINC CHAR)
		 (SETQ NO (ADD1 NO))
		 (GO LOOP)))


(DE PROCESSEXPR (EXPR)
    (PROG (PROP)
	  (COND ((ATOM EXPR) (RETURN NIL)))
	  (SETQ PROP (GETL (CAR EXPR) (QUOTE (INDFUN))))
	  (COND ((NULL PROP) (RETURN NIL)))
	  ((CADR PROP) EXPR)))

(DE TABTO (COLUMN)
    (PROG NIL
	  (COND ((GREATERP (CURCOL) COLUMN) (LINEF 1)))
	  (PRINTN (ASCII 11)
		  (*DIF	(LSH (SUB1 COLUMN) -3)
			(LSH (SUB1 (CURCOL)) -3)))
	  (PRINTN (ASCII 40) (*DIF COLUMN (CURCOL)))))

(DEFPROP DE INDEXDE INDFUN)

(DEFPROP DECLARE INDEXDECLARE INDFUN)

(DEFPROP DEFPROP INDEXDEFPROP INDFUN)

(DEFPROP DEFUN INDEXDEFUN INDFUN)

(DEFPROP DF INDEXDF INDFUN)

(DEFPROP DFUNC INDEXDFUNC INDFUN)

(DEFPROP DM INDEXDM INDFUN)

(DEFPROP LAP INDEXLAP INDFUN)

(DEFPROP SETQ INDEXSETQ INDFUN)

(DEFPROP SPECIAL INDEXSPECIAL INDFUN)

(DEFPROP EXPR T INDTYPE)

(DEFPROP FEXPR T INDTYPE)

(DEFPROP SUBR T INDTYPE)

(DEFPROP FSUBR T INDTYPE)

(DEFPROP LSUBR T INDTYPE)

(DEFPROP MACRO T INDTYPE)

(DEFPROP SPECIAL T INDTYPE)

(DEFPROP VALUE T INDTYPE)

(SETQ USEKEY T)